home *** CD-ROM | disk | FTP | other *** search
/ Graphics Plus / Graphics Plus.iso / libs / phigs / ptk.lha / ptk / fortran / source / demo / windtest.f < prev   
Encoding:
Text File  |  1992-09-29  |  8.8 KB  |  281 lines
  1. C--------------------------------------------------------------------------- 
  2.  
  3. C Program name: Windows test program.
  4.  
  5. C Author: Gareth Williams
  6.  
  7. C Description:
  8.  
  9. C Modification history : (Version), (Date), (Name), (Description).
  10.  
  11. C 1.0, 1st September 1991, G. Williams, First Version.
  12.  
  13. C 2.0, June 1992, G. Williams, Converted to SunPHIGS 2.0.
  14.  
  15. C----------------------------------------------------------------------------
  16.  
  17.        PROGRAM windtest
  18.        INTEGER minid, maxid, lampid
  19.        INTEGER lamplist(1)
  20.        INTEGER grey, green, black, white
  21.        REAL pos(2), size(2)
  22.        LOGICAL docolour
  23.        INTEGER ptkf_stringtoint
  24.        LOGICAL ptkf_readphinterscript
  25.  
  26.        include './sunphigs77.h'
  27.        
  28.          implicit undefined (P, p, E, e)
  29.  
  30. C colour or monochrome
  31.        docolour = .TRUE.
  32.  
  33. C     open PHIGS 
  34.          print *,('Demonstrating the windows module of the 
  35. & PHIGS Toolkit...')
  36.          print *,('Opening SunPHIGS...')
  37.  
  38.          call popph(6, 0)
  39.  
  40. C     create the workstation type (either tool or canvas) 
  41.               
  42. C     open the workstation 
  43.        
  44.        if (ptkf_readphinterscript('../../scripts/openws.scr', 0, 0) .eq.
  45. & .FALSE.) then     
  46.          goto 30
  47.        endif
  48.  
  49.        call psdus(1, PWAITD, PNIVE)
  50.        
  51. C     initialise hashtables 
  52.        
  53.        minid = 1
  54.        maxid = 50
  55.        call ptkf_inithashtables()
  56.        call ptkf_createhashtable('structureid', minid, maxid)
  57.        call ptkf_createhashtable('topologyid', minid, maxid)
  58.        call ptkf_createhashtable('label', minid, maxid)
  59.        call ptkf_createhashtable('colourindex', 1, 50)
  60.        call ptkf_createhashtable('viewindex', 1, 50)
  61.        call ptkf_createhashtable('name', 1, 50)
  62.               
  63.        if (docolour .eq. .TRUE.) then
  64.          call ptkf_setcolourrep(1, 'black')
  65.          call ptkf_setcolourrep(1, 'white')
  66.          call ptkf_setcolourrep(1, 'grey')
  67.          call ptkf_setcolourrep(1, 'green')
  68.          call ptkf_setcolourrep(1, 'red')
  69.          call ptkf_setcolourrep(1, 'blue')
  70.        endif
  71.  
  72.        if (ptkf_readphinterscript('../../scripts/lamp.scr', 0, 0) .eq.
  73. & .TRUE.) then
  74.          call ptkf_point(0.5, 0.5, pos)
  75.          call ptkf_point(0.6, 0.6, size)     
  76.          call ptkf_createwindow(1, 1, size, pos, 'lamp window')
  77.  
  78.          if (docolour .eq. .TRUE.) then
  79.            green = ptkf_stringtoint('colourindex', 'green')
  80.            grey = ptkf_stringtoint('colourindex', 'grey')
  81.            white = ptkf_stringtoint('colourindex', 'white')
  82.            black = ptkf_stringtoint('colourindex', 'black')
  83.            call ptkf_setwindowattrs(1, PFONTTRIPLEX, black,
  84. & green, grey, green, white, black)
  85.            call ptkf_setbackgroundcolourind(1, grey)
  86.          endif
  87.  
  88.          lampid = ptkf_stringtoint('structureid', 'lamp')
  89.          call ptkf_posttowindow(1, lampid)
  90.  
  91.          lamplist(1) = lampid
  92.          call ptkf_setcameraworld(1, 1, lamplist)
  93.          call ptkf_setcameraprojtype(1, PPERS)
  94.          call ptkf_postwindow(1)
  95.        
  96.          call ptkf_point(0.1, 0.9, pos)
  97.          call ptkf_seticonposition(1, pos)
  98.          call prst(1, PALWAY)
  99.        
  100.          call options()
  101.        endif
  102.  
  103.  30    print *,('Closing PHIGS...')
  104.        call pclwk(1)
  105.        call pclph()
  106.  
  107.        STOP
  108.        END
  109.        
  110. C--------------------------------------------------------------------------
  111.        
  112.       SUBROUTINE init_input()
  113. C     Initializes two locators, one in sample mode, 
  114. C     and one in event mode. 
  115.        CHARACTER*80 lrec(10)
  116.        CHARACTER*20 str(2)
  117.        INTEGER ia(2)
  118.        INTEGER la(2)
  119.        REAL ra(2)
  120.        REAL ea(4)
  121.        INTEGER err
  122.        REAL devx, devy
  123.  
  124.        include './sunphigs77.h'
  125.  
  126.        implicit undefined (P, p, E, e)
  127.        
  128.        call pslcm(1, 1, PREQU, PECHO)
  129.        call pslcm(1, 4, PREQU, PECHO)
  130.        
  131.        call ptkf_inqmaxdevicecoords(1, devx, devy)
  132.        
  133.        call ptkf_limit(0.0, devx, 0.0, devy, ea)
  134.  
  135.        call pprec(0, ia, 0, ra, 0, la, str, 10, err, ldr, lrec)
  136.  
  137.        call pinlc(1, 1, 0, 0.5, 0.5, 1, ea(1), ea(2), ea(3), ea(4),
  138. & ldr, lrec)
  139.        call pinlc(1, 4, 0, 0.5, 0.5, 1, ea(1), ea(2), ea(3), ea(4),
  140. & ldr, lrec)
  141.  
  142.        call pslcm(1, 1, PEVENT, PECHO)
  143.        call pslcm(1, 4, PSAMPL, PECHO)
  144.  
  145.        RETURN
  146.        END
  147.        
  148. C--------------------------------------------------------------------------
  149.        
  150.        SUBROUTINE camerainterface()
  151.        INTEGER wsid, indev, viewindex, err
  152. C Event input data. 
  153.        INTEGER class
  154.        REAL pos(2)
  155.        REAL lims(6)
  156.        REAL defcampos(3), campos(3)
  157.        REAL zorg
  158.  
  159.        include './sunphigs77.h'
  160.     
  161.        implicit undefined (P, p, E, e)
  162.        
  163.        call init_input()
  164.  
  165. C Initialise input devices. 
  166.        call ptkf_inqcameralimits(1, lims, err)
  167.        call ptkf_inqcameraposition(1, defcampos, err)
  168.        zorg = lims(5) + ((lims(6) - lims(5)) / 2.0)
  169.  20    call psmlc(1, 4, viewindex, pos(1), pos(2))
  170.        campos(1) = lims(1) + (lims(2) - lims(1)) * pos(1)
  171.        campos(2) = lims(3) + (lims(4) - lims(3)) * pos(2)
  172.        campos(3) = zorg + ((sin(3.142 * pos(1)) * sin(3.142 * pos(2)))
  173. & * (defcampos(3) - zorg))
  174.        call ptkf_setcameraposition(1, campos)
  175.        call puwk(1, PPERFO)
  176.        call pwait(0.25, wsid, class, indev)
  177. C See if left button pressed. 
  178.        if (class .ne. PLOCAT) then
  179.          goto 20
  180.        endif
  181.  
  182.        call pslcm(1, 1, PREQU, PECHO)
  183.        call pslcm(1, 4, PREQU, PECHO)
  184.  
  185.        RETURN
  186.        END
  187.        
  188. C--------------------------------------------------------------------------
  189.          
  190.          SUBROUTINE options()
  191.          CHARACTER*20 commandstr
  192.          INTEGER lencom
  193.          LOGICAL quit
  194.          REAL pos(2), size(2)
  195.          REAL echoarea(4)
  196.          REAL height
  197.          INTEGER bancol, titlecol
  198.          REAL ptkf_readfloat
  199.          INTEGER ptkf_readint
  200.  
  201.          include './sunphigs77.h'
  202.          include './sunptk77.h'
  203.  
  204.          implicit undefined (P, p, E, e)
  205.          
  206.          quit = .FALSE.
  207.          call ptkf_limit(0.0, 0.25, 0.0, 0.01, echoarea)
  208.  10      call ptkf_readstring(1, 'camera', 
  209. & 'Input command (default = camera)>', echoarea, 20, commandstr, 
  210. & lencom)
  211.          if (commandstr(1:lencom) .eq. 'camera') then
  212.            call camerainterface()
  213.          else if (commandstr(1:lencom) .eq. 'position') then
  214.            pos(1) = ptkf_readfloat(1, 0.5, 'Input position, x (0.5) >', 
  215. & echoarea)
  216.            pos(2) = ptkf_readfloat(1, 0.5, 'Input position, y (0.5) >', 
  217. & echoarea)
  218.            call ptkf_setwindowposition(1, pos)
  219.          else if (commandstr(1:lencom) .eq. 'size') then
  220.            size(1) = ptkf_readfloat(1, 0.5, 'Input size, x (0.5) >', 
  221. & echoarea)
  222.            size(2) = ptkf_readfloat(1, 0.5, 'Input size, y (0.5) >', 
  223. & echoarea)
  224.            call ptkf_setwindowsize(1, size)
  225.          else if (commandstr(1:lencom) .eq. 'iconposition') then
  226.            pos(1) = ptkf_readfloat(1, 0.5, 'Input icon position, 
  227. & x (0.5) >', echoarea)
  228.            pos(2) = ptkf_readfloat(1, 0.5, 'Input icon position, 
  229. & y (0.5) >', echoarea)
  230.            call ptkf_seticonposition(1, pos)
  231.          else if (commandstr(1:lencom) .eq. 'iconsize') then
  232.            size(1) = ptkf_readfloat(1, 0.1, 'Input icon size, 
  233. & x (0.1) >', echoarea)
  234.            size(2) = ptkf_readfloat(1, 0.1, 'Input icon size, 
  235. & y (0.1) >', echoarea)
  236.            call ptkf_seticonsize(1, size)
  237.          else if (commandstr(1:lencom) .eq. 'framesize') then
  238.            size(1) = ptkf_readfloat(1, 0.01, 'Input frame size,
  239. & x (0.01) >', echoarea)
  240.            size(2) = ptkf_readfloat(1, 0.01, 'Input frame size, 
  241. & y (0.01) >', echoarea)
  242.            call ptkf_setframesize(1, size)
  243.          else if (commandstr(1:lencom) .eq. 'open') then
  244.            call ptkf_openwindow(1)
  245.          else if (commandstr(1:lencom) .eq. 'close') then
  246.            call ptkf_closewindow(1)
  247.          else if (commandstr(1:lencom) .eq. 'front') then
  248.            call ptkf_frontwindow(1)
  249.          else if (commandstr(1:lencom) .eq. 'back') then
  250.            call ptkf_backwindow(1)
  251.          else if (commandstr(1:lencom) .eq. 'bannerheight') then
  252.            height = ptkf_readfloat(1, 0.01, 'Input banner height >', 
  253. & echoarea)
  254.            call ptkf_setbannerheight(1, height)
  255.          else if (commandstr(1:lencom) .eq. 'bannercolours') then
  256.            bancol = ptkf_readint(1, 0, 'Input banner colour index >',
  257. & echoarea)
  258.            titlecol = ptkf_readint(1, 1, 
  259. & 'Input title string colour index >', echoarea)
  260.            call ptkf_setbannercolours(1, bancol, titlecol)
  261.          else if (commandstr(1:lencom) .eq. 'phinter') then
  262.            call ptkf_callphinter()
  263.          else if (commandstr(1:lencom) .eq. 'quit') then
  264.            quit = .TRUE.
  265.          else
  266.            print *,('Command unknown')    
  267.          endif
  268.  
  269.          call prst(1, PALWAY)
  270.  
  271.          if (quit .eq. .FALSE.) then
  272.            goto 10            
  273.          endif
  274.             
  275.          RETURN
  276.          END
  277.  
  278. C--------------------------------------------------------------------------
  279.                    
  280. C     end of windtest.f
  281.